﻿'Copyright (c) 2009 Grailtek

'Permission is hereby granted, free of charge, to any person
'obtaining a copy of this software and associated documentation
'files (the "Software"), to deal in the Software without
'restriction, including without limitation the rights to use,
'copy, modify, merge, publish, distribute, sublicense, and/or sell
'copies of the Software, and to permit persons to whom the
'Software is furnished to do so, subject to the following
'conditions:

'The above copyright notice and this permission notice shall be
'included in all copies or substantial portions of the Software.

'THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
'EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
'OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
'NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
'HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
'WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
'FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
'OTHER DEALINGS IN THE SOFTWARE.

Imports System.Xml.Serialization
Imports System.Reflection

''' <summary>
''' Provides serialization assistance for dynamic types and arrays of dynamic types
''' </summary>
''' <remarks>
''' This class is designed to provide a robust and thread-safe way to serialze dynamically-created types, in particular for
''' web applications that require persisting dynamically-typed objects across postbacks. As the built-in serializer for ViewState
''' does not resolve dynamic types automatically, we substitute the object with a surrogate class that stores the object's locally
''' serialzed data, plus type information required to recreate it.
''' </remarks>
<Serializable()> _
Public Class DynamicTypeSerializer

    Public IsArray As Boolean
    Public ArrayLengths, ArrayLowerBounds As Integer()
    Public IncludeTypeNames As String()
    Public OriginalTypeName, SerializedData As String

    Public Sub New()
    End Sub

    Public Shared Function Serialize(ByVal obj As Object) As String
        Dim ds As DynamicTypeSerializer
        If TypeOf obj Is Array Then
            ds = New DynamicTypeSerializer(DirectCast(obj, Array))
        Else
            ds = New DynamicTypeSerializer(obj)
        End If
        Dim s As XmlSerializer = GetSimpleSerializerFor(GetType(DynamicTypeSerializer))
        Using w As New IO.StringWriter
            s.Serialize(w, ds)
            Return w.GetStringBuilder.ToString
        End Using
    End Function

    Public Shared Function Deserialize(Of T)(ByVal str As String) As T
        Dim ret As T = Nothing
        Dim cont As DynamicTypeSerializer = Nothing
        Dim s As XmlSerializer = GetSimpleSerializerFor(GetType(DynamicTypeSerializer))
        Using r As New IO.StringReader(str)
            Dim obj As Object = s.Deserialize(r)
            If Not obj Is Nothing Then
                cont = CType(obj, DynamicTypeSerializer)
                ret = CType(cont.GetItem(GetType(T).Assembly), T)
            End If
        End Using
        Return ret
    End Function

    Private Sub New(ByVal obj As Object)
        If Not obj Is Nothing Then
            OriginalTypeName = obj.GetType.FullName
            Dim s As XmlSerializer = GetSimpleSerializerFor(obj.GetType)
            Using w As New IO.StringWriter
                s.Serialize(w, obj)
                SerializedData = w.GetStringBuilder.ToString
            End Using
        End If
    End Sub
    Private Sub New(ByVal ary As Array)
        If Not ary Is Nothing Then
            IsArray = True
            Dim OriginalType As Type = ary.GetType.GetElementType
            OriginalTypeName = OriginalType.FullName
            ReDim ArrayLengths(ary.Rank - 1)
            ReDim ArrayLowerBounds(ary.Rank - 1)
            For i As Integer = 0 To ary.Rank - 1
                ArrayLengths(i) = ary.GetLength(i)
                ArrayLowerBounds(i) = ary.GetLowerBound(i)
            Next
            Dim IncludeTypes() As Type = CType(ary, IEnumerable(Of Object)).Select(Of Type)(Function(i As Object) If(i Is Nothing, Nothing, i.GetType)).Distinct.Where(Function(t As Type) Not t Is Nothing).ToArray()
            IncludeTypeNames = IncludeTypes.Select(Of String)(Function(t As Type) t.FullName).ToArray
            For Each t As Type In IncludeTypes : Next
            Using w As New IO.StringWriter
                Dim s As XmlSerializer = GetArraySerializerFor(IncludeTypes)
                s.Serialize(w, ary)
                SerializedData = w.GetStringBuilder.ToString
            End Using
        End If
    End Sub

#Region "serialization and type caching"

    Private Shared ArraySerializers As New Dictionary(Of String, XmlSerializer)
    Private Shared SimpleSerializers As New Dictionary(Of String, XmlSerializer)

    Private Shared ReadOnly m_clone As MethodInfo = GetType(Object).GetMethod("MemberwiseClone", BindingFlags.NonPublic Or BindingFlags.Instance)

    'NOTE: cloning may seem unnecessary but it actually provides a tremendous increase in speed; XMLSerializer's constructor is resource intensive
    '   as it generates and compiles a code file which is apparently not persisted outside of the scope of its declaration
    Private Shared Function GetArraySerializerFor(ByVal types() As Type) As XmlSerializer
        Dim typeNames() As String = types.Select(Of String)(Function(t As Type) t.FullName).ToArray
        System.Array.Sort(typeNames)
        Dim ret As XmlSerializer = Nothing
        Dim typeSetKey As String = String.Join(":"c, typeNames)
        If Not ArraySerializers.TryGetValue(typeSetKey, ret) Then
            Trace.WriteLine("constructing new serializer for dynamic typeset")
            SyncLock (ArraySerializers)
                If Not ArraySerializers.TryGetValue(typeSetKey, ret) Then
                    ret = New XmlSerializer(GetType(Object()), types)
                    ArraySerializers.Add(typeSetKey, ret)
                End If
            End SyncLock
        End If
        ret = CType(m_clone.Invoke(ret, Nothing), XmlSerializer)
        Return ret
    End Function
    Private Shared Function GetArraySerializerFor(ByVal CallingAssembly As Assembly, ByVal TypeNames() As String) As XmlSerializer
        Return GetArraySerializerFor(TypeNames.Select(Of Type)(Function(name As String) FindType(CallingAssembly, name)).ToArray)
    End Function

    Private Shared Function GetSimpleSerializerFor(ByVal type As Type) As XmlSerializer
        Dim ret As XmlSerializer = Nothing
        If Not SimpleSerializers.TryGetValue(type.FullName, ret) Then
            Trace.WriteLine("constructing new serializer for dynamic type")
            SyncLock (SimpleSerializers)
                If Not SimpleSerializers.TryGetValue(type.FullName, ret) Then
                    ret = New XmlSerializer(type)
                    SimpleSerializers.Add(type.FullName, ret)
                End If
            End SyncLock
        End If
        ret = CType(m_clone.Invoke(ret, Nothing), XmlSerializer)
        Return ret
    End Function
    Private Shared Function GetSimpleSerializerFor(ByVal CallingAssembly As Assembly, ByVal TypeName As String) As XmlSerializer
        Return GetSimpleSerializerFor(FindType(CallingAssembly, TypeName))
    End Function


    Private Shared Function FindType(ByVal CallingAssembly As Assembly, ByVal TypeName As String) As Type
        Dim ret As Type = Nothing
        If String.IsNullOrEmpty(TypeName) Then Throw New ArgumentNullException("TypeName")
        If TypeName Like System.InterfaceImplementor.ConstructedTypePrefix & "*" Then
            Dim interfaceTypeName As String = TypeName.Replace(System.InterfaceImplementor.ConstructedTypePrefix, "")
            Dim interfaceType As Type = CallingAssembly.GetType(interfaceTypeName)
            If interfaceType Is Nothing Then Throw New ArgumentException(String.Format("assembly '{0}' failed to load interface type '{1}'", CallingAssembly.FullName, interfaceTypeName))
            ret = System.ExecutorServices.GetImplementingType(interfaceType)
            If ret Is Nothing Then Throw New ArgumentException(String.Format("System.ExecutorServices failed to load interface type '{1}' for assembly '{0}'", CallingAssembly.FullName, interfaceTypeName))
        Else
            ret = CallingAssembly.GetType(TypeName)
            If ret Is Nothing Then Throw New ArgumentException(String.Format("assembly '{0}' failed to load type '{1}'", CallingAssembly.FullName, TypeName))
        End If
        Return ret
    End Function

    Private Function GetItem(ByVal CallingAssembly As Assembly) As Object
        Return If(IsArray, GetArray(CallingAssembly), GetObject(CallingAssembly))
    End Function

#End Region

    Private Function GetObject(ByVal CallingAssembly As Assembly) As Object
        Dim ret As Object = Nothing
        If Not OriginalTypeName Is Nothing Then
            Using r As New IO.StringReader(SerializedData)
                Dim retType As Type = FindType(CallingAssembly, OriginalTypeName)
                If Not retType Is Nothing Then
                    Dim s As XmlSerializer = GetSimpleSerializerFor(retType)
                    ret = s.Deserialize(r)
                End If
            End Using
        End If
        Return ret
    End Function
    Private Function GetArray(ByVal CallingAssembly As Assembly) As Object
        Dim ret As Array = Nothing
        If Not OriginalTypeName Is Nothing Then
            Dim retType As Type = FindType(CallingAssembly, OriginalTypeName)
            If Not retType Is Nothing Then
                ret = Array.CreateInstance(retType, ArrayLengths, ArrayLowerBounds)
                If Not SerializedData Is Nothing AndAlso Not IncludeTypeNames Is Nothing Then
                    Dim ary As Array = Nothing
                    Using r As New IO.StringReader(SerializedData)
                        Dim s As XmlSerializer = GetArraySerializerFor(CallingAssembly, IncludeTypeNames)
                        Dim obj As Object = s.Deserialize(r)
                        If Not obj Is Nothing Then ary = CType(obj, Array)
                    End Using
                    If Not ary Is Nothing Then
                        For rank As Integer = 0 To ret.Rank - 1
                            ary.CopyTo(ret, rank)
                        Next
                    End If
                End If
            End If
        End If
        Return ret
    End Function
End Class